home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / typing / overload.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  4.2 KB  |  140 lines
  1. (* Copyright 1989 by AT&T Bell Laboratories *)
  2. (* overload.sml *)
  3.  
  4. structure Overload : OVERLOAD = struct
  5.  
  6. open ErrorMsg Variables Types TypesUtil Unify BasicTypes
  7.  
  8. type subst = (tyvar * tvinfo) list
  9.  
  10. exception SoftUnify
  11.  
  12. local fun typeArgs n = 
  13.         if n>0
  14.         then (mkRefMETAty 0) :: typeArgs(n-1)
  15.         else []
  16.  in fun copyScheme (tyfun as TYFUN{arity,...}) : ty * ty =
  17.     let val tvs = typeArgs arity
  18.      in (applyTyfun(tyfun,tvs),
  19.          if arity>1 then tupleTy tvs else hd tvs)
  20.     end
  21. end
  22.  
  23. fun rollBack subst =
  24.     let fun loop (nil,trace) = trace
  25.       | loop (((tv as ref kind),oldkind)::subst,trace) =
  26.            (tv := oldkind;
  27.         loop(subst,(tv,kind)::trace))
  28.      in loop(subst,nil)
  29.     end
  30.  
  31. fun redoSubst nil = ()
  32.   | redoSubst ((tv as ref(OPEN{kind=META, ...}),INSTANTIATED ty)::rest) =
  33.       (tv := INSTANTIATED ty; redoSubst rest)
  34.   | redoSubst (_) = impossible "Overload--redoSubst"
  35.  
  36. fun softUnify(ty1: ty, ty2: ty): subst =
  37.     let val subst: subst ref = ref nil
  38.     fun softInst(tv as ref info: tyvar, ty: ty) : unit =
  39.         let fun scan(ty: ty) : unit =  (* simple occurrence check *)
  40.            case ty
  41.              of VARty(tv') => 
  42.                   if eqTyvar(tv, tv') then
  43.                   raise SoftUnify
  44.               else
  45.                   (case tv'
  46.                   of ref(OPEN{kind=FLEX fields,...}) =>
  47.                       app (fn (_,ty') => scan ty') fields
  48.                    | _ => ()
  49.                   )
  50.               | CONty(_, args) => app scan args
  51.               | ty => ()  (* propagate error *)
  52.          in case info
  53.           of OPEN{kind=META,...} => ()
  54.            | _ => raise SoftUnify;
  55.              scan ty;
  56.         subst := (tv, info)::(!subst);
  57.         tv := INSTANTIATED ty
  58.         end
  59.     
  60.     fun unify(ty1: ty, ty2: ty): unit =
  61.         let val ty1 = prune ty1
  62.         and ty2 = prune ty2
  63.          in case (ty1,ty2)
  64.           of (WILDCARDty, _) => ()  (* wildcards unify with anything *)
  65.            | (_, WILDCARDty) => ()  (* wildcards unify with anything *)
  66.            | (VARty(tv1),VARty(tv2)) =>
  67.                if eqTyvar(tv1,tv2) then () else softInst(tv1,ty2)
  68.            | (VARty(tv1),_) => softInst(tv1,ty2)
  69.            | (_,VARty(tv2)) => softInst(tv2,ty1)
  70.            | (CONty(tycon1, args1), CONty(tycon2, args2)) =>
  71.                if eqTycon(tycon1, tycon2)
  72.                then unifyLists(args1, args2)
  73.                else (unify(reduceType ty1, ty2)
  74.                  handle ReduceType => 
  75.                    unify(ty1, reduceType ty2)
  76.                    handle ReduceType => raise SoftUnify)
  77.            | _ => raise SoftUnify
  78.         end
  79.     
  80.     and unifyLists([],[]) = ()
  81.       | unifyLists(ty1::rest1, ty2::rest2) = 
  82.           (unify(ty1,ty2); unifyLists(rest1,rest2))
  83.       | unifyLists(_) = raise SoftUnify
  84.  
  85.      in unify(ty1,ty2)
  86.       handle SoftUnify => (rollBack(!subst); raise SoftUnify);
  87.     !subst
  88.     end
  89.  
  90. exception Overld
  91.  
  92. val overloaded = ref (nil: (var ref * ErrorMsg.complainer * ty) list)
  93.  
  94. fun resetOverloaded () = overloaded := nil
  95.  
  96. fun pushOverloaded (refvar as ref(OVLDvar{options,scheme,...}), err) = 
  97.        let val (scheme',ty) = copyScheme(scheme)
  98.         in overloaded := (refvar,err,ty) :: !overloaded;
  99.            scheme'
  100.        end
  101.   | pushOverloaded _ = impossible "overload.1"
  102.  
  103. fun resolveOverloaded env  =
  104.  let fun resolveOVLDvar(rv as ref(OVLDvar{name,options,...}),err,context) =
  105.     (let fun findFirst({indicator, variant}::rest) =
  106.          ((softUnify(applyPoly(indicator,Root), context), variant, rest)
  107.            handle SoftUnify => findFirst(rest))
  108.            | findFirst(nil) = 
  109.            (err COMPLAIN "overloaded variable not defined at type"
  110.              (fn ppstrm =>
  111.                (PPType.resetPPType();
  112.             PrettyPrint.add_newline ppstrm;
  113.             PrettyPrint.add_string ppstrm "symbol: "; 
  114.             PPUtil.ppSym ppstrm name;
  115.             PrettyPrint.add_newline ppstrm;
  116.             PrettyPrint.add_string ppstrm "type: ";
  117.             PPType.ppType env ppstrm context));
  118.             raise Overld)
  119.          fun findSecond({indicator, variant}::rest) =
  120.          ((rollBack(softUnify(applyPoly(indicator,Root), context));
  121.            err COMPLAIN
  122.              ("overloaded variable cannot be resolved: "^Symbol.name(name))
  123.              nullErrorBody;
  124.            raise Overld)
  125.           handle SoftUnify => findSecond(rest))
  126.            | findSecond(nil) = ()
  127.          val (subst,var,restOptions) = findFirst(!options)
  128.          val subst = rollBack subst
  129.       in findSecond(restOptions);
  130.          redoSubst subst;
  131.          rv := var
  132.      end handle Overld => ())
  133.        | resolveOVLDvar _ = impossible "overload.2"
  134.  
  135.   in app resolveOVLDvar (!overloaded); 
  136.      overloaded := nil
  137.  end
  138.  
  139. end (* structure Overload *)
  140.